perm filename MKCON[GEM,BGB] blob sn#050723 filedate 1973-08-08 generic text, type T, neo UTF8
00100	COMMENT ⊗   VALID 00022 PAGES
00200	C REC  PAGE   DESCRIPTION
00300	C00001 00001
00400	C00004 00002	TITLE MKCON - MAKE CONTOUR IMAGE - APRIL 1973 - B. G. BAUMGART.
00500	C00005 00003	SUBR(MKCON)Q1,Q2.	MAKE: CONTOUR IMAGE FROM VIDEO.
00600	C00007 00004	  SUBRS:		MAKE: MKIMAG(FILM). MKLEVL(IMAGE,CUT).
00700	C00009 00005	  SUBRS:		MAKE: THRESH(CUT). PAXOR.
00800	C00011 00006	SUBR(MKPGON)LEVEL	MAKE: POLYGON BY TRACING BIT RASTER BLOB.
00900	C00013 00007				MAKE: MKPGON SUB-OPERATIONS.
01000	C00014 00008				MAKE: THE ALCHEMIST OF MKPGON.
01100	C00017 00009	SUBR(VICONT)LEVEL	CONTRAST: VECTOR INTENSITY CONTRAST.
01200	C00020 00010				CONTRAST: VICONT CONTINUED.
01300	C00023 00011	SUBR(ARCONT)LEVEL	CONTRAST: ARC CONTRAST.
01400	C00025 00012	SUBR(MKSKY)LEVEL	NESTING: MAKE BORDER POLYGON & SKY ARRAY.
01500	C00028 00013	  SUBRS:		NESTING: MKTREEATTACHDETACH
01600	C00031 00014	SUBR(INTREE)P1.		NESTING: PUT POLYGON INTO THE TREE.
01700	C00033 00015				NESTING: INTREE CONTINUED.
01800	C00035 00016	SUBR(INSKY)PGON		NESTING: PUT A POLYGON IN THE SKY ARRAY.
01900	C00037 00017	SUBR(KILVIC)LEVEL.	KILL: CONTOURS OF THE PREVIOUS LEVEL.
02000	C00038 00018	SUBR(KLBABY)LEVEL	KILL: BABY POLYGONS OF A LEVEL.
02100	C00040 00019	SUBR(KLPGON)PGN		KILL: POLYGON AND RETURN CCW(PGN).
02200	C00042 00020	SUBR(SMOOTH)LEVEL	SMOOTH: CONTOURS INTO ARCS.
02300	C00044 00021	MKARCS(V1,V2).		SMOOTH: MAKE ARCS FROM V1 CCW TO V2.
02400	C00047 00022	SUBR(HISTOG)		MISC: MAKE HISTOGRAM OF TVBUF.
02500	C00052 ENDMK
02600	C⊗;
     

00100	TITLE MKCON - MAKE CONTOUR IMAGE - APRIL 1973 - B. G. BAUMGART.
00200	
00300		EXTERN PUTSKY,GETSKY
00400		EXTERN FLGHIS,ARCWID,CTRL,META
00500		EXTERN PAC,STADPY,TVBUF
00600		EXTERN HISTO,HSEG,VSEG,FILM
00700		EXTERN ROWPTR,COLPTR,DPYIMG
00800		EXTERN MKNODD,KLNODD,RINGIN
00900		EXTERN SQRT
01000	
01100		DECLARE{IMAGE,LEVEL,POLYGON}
01200	
01300	;ENABLE SUBROUTINE FLAGS.
01400		INTERN ENEST,ECONT,ESMOO,ECOMP
01500		ENEST:-1	;POLYGON NESTING.
01600		ECONT:-1	;VECTOR AND ARC CONTRAST.
01700		ESMOO:-1	;MAKE ARC SMOOTHING.
01800		ECOMP:-1	;IMAGE COMPARING.
     

00100	SUBR(MKCON)Q1,Q2.	MAKE: CONTOUR IMAGE FROM VIDEO.
00200	BEGIN MKCON;---------------------------------------------------
00300	
00400	;BIT POSITIONS OF THE ARGUMENTS Q1 & Q2 ENABLE INTENSITY CUTS.
00500		LAC 1,ARG2↔DAC 1,Q0
00600		LAC 1,ARG1↔ANDCMI 1,377↔DAC 1,Q1
00700		DZM CUT#
00800	
00900	;MAKE THE IMAGE BLOCK AND THE LEVEL -1 FRAME POLYGON.
01000		SETQ IMAGE,{MKIMAG,FILM}
01100		SETQ LEVEL,{MKLEVL,IMAGE,[-1]}
01200		SETQ POLYGON,{MKSKY,LEVEL}	;BORDER & SKY.
01300	
01400	;FIND AN INTENSITY CONTOUR ENABLE BIT.
01500	L0:	LAC 0,Q0↔LAC 1,Q1
01600	L1:	AOS 2,CUT↔LSHC 0,1↔JUMPL 0,L2
01700		CAMN 0,1↔JUMPE 0,L5↔GO L1
01800	
01900	;THRESHOLD THE TVBUF
02000	L2:	DAC 0,Q0↔DAC 1,Q1
02100		CALL(THRESH,CUT)
02200		CALL(PACXOR)
02300	
02400	;MAKE LEVEL NODE WITH A RING OF POLYGON NODES.
02500		SETQ(LEVEL,{MKLEVL,IMAGE,CUT})
02600	L3:	SETQ(POLYGON,{MKPGON,LEVEL})
02700		JUMPN 1,L3↔LAC 1,LEVEL↔SON 1,1↔JUMPE 1,L0
02800	
02900	;LEVEL OPERATIONS.
03000	L4:	CALL(VICONT,LEVEL)
03100		CALL(KLBABY,LEVEL)
03200		CALL(SMOOTH,LEVEL)
03300		CALL(ARCONT,LEVEL)
03400		CALL(MKTREE,LEVEL)
03500		CALL(KILVIC,LEVEL)
03600		CALL(STADPY)
03700		GO L0
03800	
03900	;LAGGING LEVEL OPERATIONS.
04000	L5:	LAC 1,LEVEL↔CCW 1,1↔DAC 1,LEVEL
04100		CALL(KILVIC,LEVEL)
04200		LAC 1,IMAGE↔POP2J
04300	
04400		DECLARE{Q0,Q1}
04500	BEND MKCON; BGB 6 DECEMBER 1972 ----------------------------------
     

00100	;  SUBRS:		MAKE: MKIMAG(FILM). MKLEVL(IMAGE,CUT).
00200	SUBR(MKIMAG)FILM--------------------------------------------------
00300	BEGIN MKIMAG; MAKE IMAGE NODE - BGB - 10 JANUARY 1973.
00400		EXTERN QIMAGE
00500		SETQ(IMAGE,{MKNODD,[IBIT+IMGREL]})
00600		CALL(RINGIN,IMAGE,FILM)
00700		LAC 1,IMAGE↔CW 2,1		;PREVIOUS IMAGE.
00800		NCNT 2,2↔AOS 2↔NCNT. 2,1	;IMAGE SEQUENCE NUMBER.
00900		DAC 1,QIMAGE
01000		POP1J
01100	BEND;1/10/73------------------------------------------------------
01200	
01300	SUBR(MKLEVL)IMAGE,CUT---------------------------------------------
01400	BEGIN MKLEVL; MAKE LEVEL NODE - BGB - 10 JANUARY 1973.
01500		SETQ(LEVEL,{MKNODD,[LBIT+LVLREL]})
01600		CALL(RINGIN,LEVEL,IMAGE)
01700		LAC 1,LEVEL↔LAC 2,ARG2
01800		LAC 0,ARG1↔NCNT. 0,1
01900		POP2J
02000	BEND;1/10/73------------------------------------------------------
     

00100	;  SUBRS:		MAKE: THRESH(CUT). PAXOR.
00200	SUBR(THRESH)------------------------------------------------------
00300	BEGIN THRESH
00400	;SOUTH TO PAC FOR PIXELS ≥ CUT.
00500		I←13 ↔ J←14
00600		LAC [XWD L,2]↔BLT 13
00700		LAP 5,ARG1
00800		GO 3
00900	
01000	;ACCUMULATOR LOOP.
01100	L:	POINT 6,TVBUF,-1
01200		MOVEI J,=36	;3
01300		ILDB 2		;4
01400		SUBI ;CUT	;5
01500		ROTC 1		;6
01600		SOJG J,4	;7
01700		SETCAM 1,PAC(I) ;10
01800		AOBJN I,3	;11
01900		POP1J		;12
02000		XWD -=1728,0	;13
02100	BEND THRESH;BGB 4 DECEMBER 1972 ----------------------------------
02200	
02300	
02400	;PACXOR.		ROOK'S MOVE XOR'ING ON 1-BIT IMAGE.
02500	SUBR(PACXOR)------------------------------------------------------
02600	BEGIN PACXOR
02700		I←2
02800		SLACI PAC↔LAPI HSEG↔BLT HSEG+=1727
02900		SLACI PAC↔LAPI VSEG↔BLT VSEG+=1727
03000		SETZ I,
03100		HRRI PAC↔DAP L+2
03200	L:	TRNN I,7↔SETZ 1,↔LAC PAC(I)
03300		XORM HSEG+8(I)		;HSEG's are above PAC bits.
03400		ROTC -1↔ROT 1,1
03500		XORM VSEG(I)		;VSEG's are left of PAC bits.
03600		AOS I
03700		CAIE I,=1728
03800		GO L
03900		POP0J
04000	BEND PACXOR; BGB 4 DECEMBER 1972 ---------------------------------
     

00100	SUBR(MKPGON)LEVEL	MAKE: POLYGON BY TRACING BIT RASTER BLOB.
00200	BEGIN MKPGON;------------------------------------------------------
00300	
00400		ACCUMULATORS{A2,A3,RC.,MASK,I,PTR,D,E,V,PG,BITQ,H1,H2}
00500		LAC 1,ARG1↔NCNT H1,1↔LSH H1,-3
00600		LACI H2,7↔SUB H2,H1
00700		LAC I,ISAVED#↔CDR PTR,ARG1↔LACI BITQ,VREL
00800		SLACI I↔HRRI PAC↔DAC PACPTR#; PAC POINTER INDEXED BY I.
00900	
01000	;FIND THE ROW & COL OF THE UPPER LEFT MOST VSEG.
01100	L1:	SKIPE 1,VSEG(I)↔GO L2
01200		AOS I↔CAIE I,=1728↔GO L1
01300		SETZB 1,ISAVED#↔POP1J		;PAC IS NOW EMPTY.
01400	
01500	L2:	DAC I,ISAVED↔JFFO 1,.+1↔SLACI MASK,400000
01600		MOVNS 2↔LSH MASK,(2)↔MOVNS 2
01700		LAC RC.,I↔ANDI RC.,7↔IMULI RC.,=36↔ADD RC.,2	;COLUMN.
01800		LAC I↔LSH -3↔DIP RC.↔LSH RC.,6			;ROW.
01900	
02000	;DISTINGUISH BLOBS FROM HOLES.
02100		DZM HOLE#
02200		TDNN MASK,@PACPTR		;HOLE OR BLOB ?
02300		SETOM HOLE#			;HOLE'A'COMING.
02400		SKIPE HOLE↔EXCH H1,H2
02500	
02600	;AND HEAD SOUTH.
02700	
02800		SETQ(PG,{MKNODD,[PBIT+PGNREL]})
02900		LAC 0,ARG1↔DAD. 0,PG↔CALL(RINGIN,PG,0)
03000		SKIPE HOLE↔GO[MARK PG,HOLBIT↔GO .+1]
03100		DAC  RC.,RCMIN#
03200		DZM RCMAX#
03300		SETZ V,↔DZM ECNT#
03400		PUSHJ P,FOLLOW
03500		LAC V,V0
03600		CCW. V,E↔CW. E,V
03700	
03800	;MAKE & RETURN VIC POLYGON.
03900	
04000		LAC 1,ECNT↔SKIPE HOLE#↔MOVNS 1
04100	 	NCNT. 1,PG
04200		LAC V0↔SON. 0,PG	;UPPER MOST LEFT.
04300		LAC V1↔ARC. 0,PG	;LOWER MOST RIGHT.
04400		LAC 1,PG
04500	L3:	POP1J
     

00100	;			MAKE: MKPGON SUB-OPERATIONS.
00200	
00300	DEFINE	TRY (SEG,YES) {
00400		LAC SEG(I)↔TDZN MASK↔GO .+3↔DAC SEG(I)↔GO YES}
00500	DEFINE	LEFT	{SUBI RC.,100↔ROT MASK,1↔CAIN MASK,1↔SOS I}
00600	DEFINE	RIGHT	{ADDI RC.,100↔ROT MASK,-1↔SKIPG MASK↔AOS I}
00700	DEFINE	UP 	{SUB RC.,[1B11]↔SUBI I,8}
00800	DEFINE	DOWN  	{ADD RC.,[1B11]↔ADDI I,8}
00900	
01000	;CREATE NEW EDGE AND VERTEX OF A VIC.
01100	TURN:	0
01200		AOS TURNS#
01300		ADD D,RC.
01400		AOS 2,ECNT
01500	
01600	;VERTEX
01700		CALL(MKNODD,BITQ)
01800		DAD. PG,1
01900		SKIPN V↔GO[DAC 1,V0#↔DAC 1,V↔GO T2]
02000		DAC 1,V
02100		CCW. V,E↔CW. E,V
02200	T2:	DAC D,RC(V)
02300		CAMLE D,RCMAX
02400		GO[DAC D,RCMAX↔DAC V,V1#↔GO .+1]
02500		DAC V,E
02600		GO @TURN
     

00100	;			MAKE: THE ALCHEMIST OF MKPGON.
00200		;converts bits of lead into lines of gold.
00300	
00400	NORTH:	ADD D,[1B11]↔LIPI BITQ,(NORBIT+VBIT)↔JSR TURN
00500	NORTH2:	LEFT↔LAC D,DELPM(H1)↔TRY HSEG,WEST
00600		RIGHT↔UP↔TRY VSEG,NORTH2
00700		DOWN↔LAC D,DELPP(H2)↔TRY HSEG,EAST↔FATAL(NORTH)
00800	NORTH3:	LIPI BITQ,(NORBIT+VBIT)↔JSR TURN↔LEFT
00900	NORTH4:	UP↔LAC D,DELPM(H1)↔TRY HSEG,WEST↔GO NORTH4
01000	
01100	
01200	WEST:	ADDI D,100↔LIPI BITQ,(WESBIT+VBIT)↔JSR TURN
01300	WEST2:	CAMN RC.,RCMIN↔POPJ P,
01400	FOLLOW:	LAC D,DELPP(H1)↔TRY VSEG,SOUTH
01500		LEFT↔TRY HSEG,WEST2
01600		RIGHT↔UP↔LAC D,DELMP(H2)↔TRY VSEG,NORTH↔FATAL(WEST)
01700	
01800	
01900	SOUTH:	LIPI BITQ,(SOUBIT+VBIT)↔JSR TURN
02000	SOUTH2:	DOWN↔LAC D,DELMP(H1)
02100		CAR RC.↔CAIN =216B29↔GO EAST3
02200		TRY HSEG, EAST↔TRY VSEG,SOUTH2
02300		LEFT↔LAC D,DELMM(H2)↔TRY HSEG,WEST↔FATAL(SOUTH)
02400	
02500	
02600	EAST:	LIPI BITQ,(EASBIT+VBIT)↔JSR TURN
02700	EAST2:	RIGHT↔LAC D,DELMM(H1)
02800		CDR RC.↔CAIN =288B29↔GO NORTH3
02900		UP↔TRY VSEG,NORTH
03000		DOWN↔TRY HSEG,EAST2
03100		LAC D,DELPM(H2)↔TRY VSEG,SOUTH↔FATAL(EAST)
03200	EAST3:	LIPI BITQ,(EASBIT+VBIT)↔JSR TURN↔UP
03300	EAST4:	RIGHT↔LAC D,DELMM(H1)
03400		CDR RC.↔CAIN =288B29↔GO[DOWN↔GO NORTH3]
03500		TRY VSEG,NORTH↔GO EAST4
03600	
03700	;DEKINKING OFF SETS.
03800	
03900		DELPP:	FOR I←24,33{XWD I,I↔}
04000		DELPM:	FOR I←24,33{XWD I,-I↔}
04100		DELMP:	FOR I←24,33{XWD -I,I↔}
04200		DELMM:	FOR I←24,33{XWD -I,-I↔}
04300	
04400	
04500	BEND MKPGON;BGB AUGUST 1972 ---------------------------------------
     

00100	SUBR(VICONT)LEVEL	CONTRAST: VECTOR INTENSITY CONTRAST.
00200	COMMENT ⊗
00300	The contrast of a vector is defined  as (QUOTIENT (DIFFERENCE (Sum of
00400	pixel values  on one side of the vector) (Sum  of pixel values on the
00500	other side of the vector)) (length of the vector in  pixels)). Since,
00600	vectors  are always  either  horizontal or  vertical,  there are  two
00700	inner  most  loops.  For horizontal  vectors  two  byte  pointers are
00800	incremented up core west to east a row apart thru  the TVBUF. For the
00900	vertical vectors  one byte pointer is saved  then LDB'ed and ILDB'ed,
01000	and then is restored and bumped a row by the code at line NSL:
01100	⊗;
01200	
01300	BEGIN VICONT;--------------------------------------------------------
01400		ACCUMULATORS{R1,C1,V1,R2,C2,V2,PG,SUM1,SUM2,CNT,PTR,SAVCNT}
01500		SKIPN ECONT↔POP1J
01600		LAC 1,ARG1↔SON PG,1↔DAC PG,PG0#		;FIRST POLYGON.
01700	L1:	SON V2,PG↔DAC V2,V0#			;FIRST VECTOR.
01800		ROW R2,V2↔ADDI R2,40↔LSH R2,-6
01900		COL C2,V2↔ADDI C2,40↔LSH C2,-6
02000	
02100	L2:	LAC V1,V2↔LAC R1,R2↔LAC C1,C2↔CCW V2,V2	;NEXT VECTOR.
02200		ROW R2,V2↔ADDI R2,40↔LSH R2,-6
02300		COL C2,V2↔ADDI C2,40↔LSH C2,-6
02400		SETZB SUM1,SUM2
02500		TESTZ V1,WESBIT↔GO WEST
02600		TESTZ V1,SOUBIT↔GO SOUTH
02700		TESTZ V1,EASBIT↔GO EAST
02800		TESTZ V1,NORBIT↔GO NORTH↔HALT
02900	L3:	CAME V2,V0↔GO L2↔CCW PG,PG	;NEXT POLYGON.
03000		CAME PG,PG0↔GO L1↔POP1J		;EXIT.
03100	;-----------------------------------------------------------------
     

00100	;			CONTRAST: VICONT CONTINUED.
00200	WEST:	LAC ROWPTR(R2)↔ADD COLPTR-1(C2)↔TLZ 1
00300		LAC CNT,C1↔SUB CNT,C2↔CALL(EW)		;CNT ← C1-C2
00400		SUB SUM2,SUM1
00500		NTIME. SUM2,V1↔PTIME. SAVCNT,V1
00600		IDIV SUM2,SAVCNT
00700		CNTRS. SUM2,V1↔GO L3
00800	SOUTH:	LAC ROWPTR(R1)↔ADD COLPTR-1(C1)↔TLZ 1
00900		LAC CNT,R2↔SUB CNT,R1↔CALL(NS)		;CNT ← R2-R1
01000		SUB SUM2,SUM1
01100		NTIME. SUM2,V1↔PTIME. SAVCNT,V1
01200		IDIV SUM2,SAVCNT
01300		CNTRS. SUM2,V1↔GO L3
01400	EAST: 	LAC ROWPTR(R1)↔ADD COLPTR-1(C1)↔TLZ 1
01500		LAC CNT,C2↔SUB CNT,C1↔CALL(EW)		;CNT ← C2-C1
01600		SUB SUM1,SUM2
01700		NTIME. SUM1,V1↔PTIME. SAVCNT,V1
01800		IDIV SUM1,SAVCNT
01900		CNTRS. SUM1,V1↔GO L3
02000	NORTH:	LAC ROWPTR(R2)↔ADD COLPTR-1(C2)↔TLZ 1
02100		LAC CNT,R1↔SUB CNT,R2↔CALL(NS)		;CNT ← R1-R2
02200		SUB SUM1,SUM2
02300		NTIME. SUM1,V1↔PTIME. SAVCNT,V1
02400		IDIV SUM1,SAVCNT
02500		CNTRS. SUM1,V1↔GO L3
02600		DECLARE{PTRNW,PTRSE}
02700	;-----------------------------------------------------------------
02800	;EAST-WEST HORIZONAL VECTORS.
02900	EW:	DAC CNT,SAVCNT
03000		DAC PTRSE
03100		SUBI=48↔DAC PTRNW
03200	EWL:	ILDB PTRNW↔ADDM SUM1
03300		ILDB PTRSE↔ADDM SUM2
03400		SOJG CNT,EWL
03500	
03600		CAIG R1,0↔SETZ SUM1,
03700		CAIL R1,=216↔SETZ SUM2,
03800		POP0J
03900	
04000	;NORTH-SOUTH VERTICAL VECTORS.
04100	NS:	DAC CNT,SAVCNT↔DAC PTR↔TDCA 1,1
04200	
04300	NSL:	LACI 1,=48↔ADDB 1,PTR
04400		 LDB 1↔ADDM SUM1
04500		ILDB 1↔ADDM SUM2
04600		SOJG CNT,NSL
04700		CAIG  C1,0↔SETZ SUM1,
04800		CAIL  C1,=288↔SETZ SUM2,↔POP0J
04900	BEND VICONT; BGB 14 DECEMBER 1972 --------------------------------
     

00100	SUBR(ARCONT)LEVEL	CONTRAST: ARC CONTRAST.
00200	BEGIN ARCONT;-----------------------------------------------------
00300		ACCUMULATORS{QNS,QEW,A1,A2,V1,V2,PG,PG0,A0}
00400		SKIPN ECONT↔POP1J↔SKIPN ESMOO↔POP1J
00500	;FOR ALL THE ARCS OF THIS LEVEL.
00600		LAC 1,ARG1
00700		SON PG,1↔DAC PG,PG0	;FIRST POLYGON.
00800	L1:	ARC A2,PG↔DAC A2,A0	;FIRST ARC.
00900	L2:	LAC A1,A2↔SON V1,A1
01000		CCW A2,A1↔SON V2,A2
01100	
01200	;ACCUMULATE VECTOR CONTRAST,,LENGTH ALONG THE ARC.
01300		SETZB QNS,QEW
01400	L3:	TESTZ V1,NORBIT+SOUBIT↔GO[
01500		ADD QNS,6(V1)↔GO .+2]
01600		ADD QEW,6(V1)↔DZM 6(V1)
01700		CCW V1,V1
01800		CAME V1,V2↔GO L3
01900	
02000	;COMPUTE ARC CONTRAST:  SIN↑2*VERTICAL + COS↑2*HORIZONTAL.
02100		CAR 0,QNS↔FSC 0,233
02200		CDR 1,QNS↔FSC 1,233↔FDVR 0,1
02300		HLLZ 1,6(A1)↔FMPR 0,1↔DAC 0,QNS
02400		CAR 0,QEW↔FSC 0,233
02500		CDR 1,QEW↔FSC 1,233↔FDVR 0,1
02600		HRLZ 1,6(A1)↔FMPR 0,1↔FADR 0,QNS
02700		FIX 0,233000↔CNTRS. 0,A1↔DZM 6(V1)↔DZM 6(A1)
02800	
02900		CAME A2,A0↔GO L2	;LAST ARC OF THE POLYGON ?
03000		CCW PG,PG
03100		CAME PG,PG0↔GO L1	;LAST POLYGON OF THE LEVEL ?
03200		POP1J
03300	BEND ARCONT; 21 JANUARY 1973 -------------------------------------
     

00100	SUBR(MKSKY)LEVEL	NESTING: MAKE BORDER POLYGON & SKY ARRAY.
00200	BEGIN MKSKY;------------------------------------------------------
00300	
00400		ACCUMULATORS{R,C,N,S,E,W,M,LVL}
00500	
00600	;MAIN BORDER POLYGON.
00700		SETQ(M,{MKNODD,[PBIT+PGNREL]})
00800		LAC LVL,ARG1↔DAD. LVL,1
00900		CALL(RINGIN,M,LVL)
01000		LACI R,=216⊗6↔LACI C,=288⊗6
01100	
01200	;VERTEX-POLYGON POLYGON.
01300		SETQ(W,{MKNODD,[VBIT+SOUBIT+VREL]})↔DAD. M,W
01400		SETQ(S,{MKNODD,[VBIT+EASBIT+VREL]})↔DAD. M,S
01500		SETQ(E,{MKNODD,[VBIT+NORBIT+VREL]})↔DAD. M,E
01600		SETQ(N,{MKNODD,[VBIT+WESBIT+VREL]})↔DAD. M,N
01700		ROW. R,S↔ROW. R,E↔COL. C,E↔COL. C,N
01800		CW.  N,W ↔ CW.  E,N ↔ CW.  S,E ↔ CW.  W,S
01900		CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
02000		SON. W,M↔LAC 1,M
02100	
02200	
02300	;PUT THE BORDER POLYGON UP IN THE SKY.
02400		CDR GETSKY↔DZM@↔DIP↔AOS
02500		CDR 1,GETSKY↔BLT ==31500-1(1)
02600		SETZ C,↔LACI R,=216↔LAC W
02700		XCT PUTSKY(R)↔SOJGE R,.-1
02800		LACI R,=216↔LACI C,=288↔LAC E
02900		XCT PUTSKY(R)↔SOJGE R,.-1
03000	
03100	;ARC BORDER POLYGON.
03200		LACI R,=216⊗6↔LACI C,=288⊗6
03300		CALL(MKNODD,[ARCBIT+VBIT+VREL])↔SON. 1,W↔SON. W,1↔LAC W,1
03400		CALL(MKNODD,[ARCBIT+VBIT+VREL])↔SON. 1,S↔SON. S,1↔LAC S,1
03500		CALL(MKNODD,[ARCBIT+VBIT+VREL])↔SON. 1,E↔SON. E,1↔LAC E,1
03600		CALL(MKNODD,[ARCBIT+VBIT+VREL])↔SON. 1,N↔SON. N,1↔LAC N,1
03700		ROW. R,S↔ROW. R,E↔COL. C,E↔COL. C,N
03800		DAD. M,W↔DAD. M,S↔DAD. M,E↔DAD. M,N
03900		CW.  N,W ↔ CW.  E,N ↔ CW.  S,E ↔ CW.  W,S
04000		CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
04100		ARC. W,M↔LAC 1,M↔POP1J
04200	BEND MKSKY; BGB 4 DECEMBER 1972 ----------------------------------
     

00100	;  SUBRS:		NESTING: MKTREE;ATTACH;DETACH;
00200	SUBR(MKTREE)LEVEL
00300	BEGIN MKTREE;---------------------------------------------------
00400		SKIPN ENEST↔POP1J
00500	;PLACE POLYGONS OF THIS LEVEL IN THE TREE AND IN THE SKY.
00600		LAC 1,ARG1↔SON 1,1↔DAC 1,PG0#↔DAC 1,POLYGON
00700	L1:	CALL(INTREE,POLYGON)
00800		LAC 1,POLYGON
00900		CCW 1,1
01000		DAC 1,POLYGON
01100		CAME 1,PG0↔GO L1
01200		POP1J
01300	BEND MKTREE; BGB 19 DECEMBER 1972 --------------------------------
01400	
01500	SUBR(ATTACH)P1,P2-----------------------------------------------
01600	BEGIN ATTACH;PLACE P1 WITHIN P2 - BGB - 23 JANUARY 1973.
01700		LAC 1,ARG2↔LAC 2,ARG1
01800		EXO. 2,1↔ENDO 3,2	;EXO(P1)←P2;P3←ENDO(P);
01900		JUMPN 3,.+5		;IF P3=0 THEN BEGIN
02000		ENDO. 1,2↔PGON. 1,1	;ENDO(P2)←NGON(P1)←PGON(P1)←P1;
02100		NGON. 1,1↔POP2J		;RETURN;END;
02200		NGON 4,3		;P4←NGON(P3);
02300		PGON. 1,4↔NGON. 1,3	;PGON(P4)←NGON(P3)←P1;
02400		NGON. 4,1↔PGON. 3,1	;NGON(P1)←P4;PGON(P1)←P3;
02500		POP2J
02600	BEND;1/23/73------------------------------------------------------
02700	
02800	SUBR(DETACH)P1--------------------------------------------------
02900	BEGIN DETACH;REMOVE P1 FROM THE TREE - BGB - 23 JANUARY 1973.
03000		LAC 1,ARG1
03100		NGON 2,1↔PGON 3,1	;P2←NGON(P1);P3←PGON(P1);
03200		PGON. 3,2↔NGON. 2,3	;PGON(P2)←P3;NGON(P3)←P2;
03300		NGON. 1,1↔PGON. 1,1	;NGON(P1)←PGON(P1)←P1;
03400		CAMN 3,1↔SETZ 3,	;IF P3=P1 THEN P3←NIL;
03500		EXO 2,1↔ENDO 0,2	;P2←EXO(P1);P0←ENDO(P2);
03600		CAMN 0,1↔ENDO. 3,2	;IF P0=P1 THEN ENDO(P2)←P3;
03700		POP1J
03800	BEND;1/23/73------------------------------------------------------
     

00100	SUBR(INTREE)P1.		NESTING: PUT POLYGON INTO THE TREE.
00200	BEGIN INTREE;-----------------------------------------------------
00300	
00400		ACCUMULATORS{R,C,E,LST,P0,P1,P2,P3}
00500		LAC P1,ARG1
00600		SON E,P1↔JUMPE E,POP1J.
00700		ROW R,(E)↔ADDI R,40↔LSH R,-6
00800		COL C,(E)↔ADDI C,40↔LSH C,-6
00900		TESTZ P1,HOLBIT↔SOS C
01000	
01100	;FIND THE VERTICAL EDGE DUE EAST OF HERE.
01200	L0:	XCT GETSKY(R)↔SKIPN 1↔SOJA C,L0
01300		ANDCMI 1,%↔DAD P2,1↔CAMN P2,P1↔SOJA C,L0
01400	
01500	;PLACE P1 WITHIN P2, IN THE TREE AND IN THE SKY.
01600		TEST  1,SOUBIT↔EXO P2,P2
01700		CALL(ATTACH,P1,P2)
01800		CALL(INSKY,P1)
01900	
02000	;CONS UP LIST OF P2'S ENDO POLYGONS.
02100		LAC P1,ARG1↔HRLOI LST,0			;LIST ← NIL.
02200		EXO P2,P1↔ENDO P3,P2↔JUMPE P3,POP1J.	;AIN'T NONE.
02300		DAC P3,P0
02400	L1:	CAMN P3,P1↔GO L2
02500		PTIME. LST,P3↔LAC LST,P3		;CONS P3 TO LIST.
02600	L2:	NGON P3,P3↔CAME P3,P0↔GO L1		;CDR THE RING.
02700	
     

00100	;			NESTING: INTREE CONTINUED.
00200	;SCAN LIST FOR P1 ENDO POLYGONS. P2←CDR(LIST).
00300	L3:	CAIN LST,-1↔SETZ LST,
00400		SKIPN P2,LST↔POP1J↔SON E,P2
00500		ROW R,E↔ADDI R,40↔LSH R,-6
00600		COL C,E↔ADDI C,40↔LSH C,-6
00700	
00800	;SCAN FOR FIRST POLYGON TO THE EAST OF P2.
00900	L4:	JUMPL C,L7
01000		XCT GETSKY(R)↔SKIPN 1↔SOJA C,L4
01100		TRNE 1,%↔GO[TRC 1,%
01200		DAD P3,1↔CAMN P3,LST↔GO L7↔GO .+4]
01300		DAD P3,1↔CAMN P3,LST↔SOJA C,L4
01400		TESTZ 1,SOUBIT↔GO L5			;SKIP ON BRO. GO ON DAD.
01500	
01600	;IF BROTHER IS NOT ON THE P-LIST THEN EXO(P3) IS VALID.
01700	L4A:	LAC P0,P3↔EXO P3,P3
01800		PTIME 0,P0↔JUMPE 0,L5
01900	;IF BROTHER IS ON P-LIST THEN EXO(P3) IS NOT YET VALID AND MUST
02000	;BE SAVED ON AN N-LIST.
02100		NTIME 0,P0↔NTIME. 0,P2
02200		NTIME. P2,P0↔GO L6
02300	
02400	;CHECK FOR P1 CAPTURE OF P2. P3 IS THE SKY-EXO(P2).
02500	L5:	EXO 0,P2
02600		CAMN 0,P3↔GO L6		;EXO(P2)=SKYEXO(P2).
02700		CALL(DETACH,P2)
02800		CALL(ATTACH,P2,P1)
02900	
03000	;CAPTURE OLDER BROTHER OFF THE N-LIST OF P2.
03100	L6:	LAC 1,P2↔SETZ
03200		NTIME P2,P2
03300		NTIME. 0,1
03400		JUMPN P2,L5
03500	
03600	;CDR THE P-LIST OF POTENTIAL ENDO POLYGONS.
03700	L7:	LAC 1,LST↔SETZ
03800		PTIME LST,LST↔PTIME. 0,1
03900		GO L3
04000	BEND INTREE; BGB 23 JANUARY 1973 ---------------------------------
     

00100	SUBR(INSKY)PGON		NESTING: PUT A POLYGON IN THE SKY ARRAY.
00200	BEGIN INSKY;------------------------------------------------------
00300	
00400		ACCUMULATORS{R,C,R2,C2,E,E2}
00500	
00600	DEFINE ADVANCE{
00700		LAC E,E2↔LAC R,R2↔LAC C,C2
00800		CCW E2,E2
00900		ROW R2,E2↔ADDI R2,40↔LSH R2,-6
01000		COL C2,E2↔ADDI C2,40↔LSH C2,-6}
01100	
01200	;XWD HORIZONTAL,,VERTICAL.
01300		LAC 1,ARG1↔SON E,1
01400		DAC E,E0#↔JUMPE E,POP1J.
01500		CW E2,E↔ADVANCE↔ADVANCE↔GO S1
01600	
01700	;SOUTH ↓ BOUND.
01800	S0:	CAMN E,E0↔POP1J
01900	S1:	LAC E↔XCT GETSKY(R)
02000		SKIPE 1↔TRC %↔XCT PUTSKY(R)
02100		CAIE R2,(R)1↔AOJA R,S1↔ADVANCE
02200		TEST E,EASBIT↔GO W0↔GO EE0
02300	
02400	;NORTH ↑ BOUND.
02500	N0:	SOS R
02600	N1:	LAC E↔XCT GETSKY(R)
02700		SKIPE 1↔TRC %↔XCT PUTSKY(R)
02800		CAME R,R2↔SOJA R,N1↔ADVANCE
02900		TEST E,EASBIT↔GO W0↔GO EE0
03000	
03100	;EAST → BOUND.
03200	EE0:	ADVANCE
03300		TEST E,NORBIT↔GO S0↔GO N0
03400	
03500	;WEST ← BOUND.
03600	W0:	ADVANCE
03700		TEST E,NORBIT↔GO S0↔GO N0
03800	
03900	BEND INSKY;BGB 7 DECEMBER 1972 -----------------------------------
     

00100	SUBR(KILVIC)LEVEL.	KILL: CONTOURS OF THE PREVIOUS LEVEL.
00200	BEGIN KILVIC;-----------------------------------------------------
00300		ACCUMULATORS{PG,E0,E1,E2,PG0}
00400		SKIPN ESMOO↔POP1J
00500		LAC 1,ARG1↔CW 1,1
00600		SON PG,1
00700		SKIPN PG0,PG↔POP1J
00800	
00900	;RELEASE VIC NODES OF THE POLYGON.
01000	L1:	SON E0,PG
01100		TESTZ E0,ARCBIT↔GO L3
01200		ARC 0,PG↔SON. 0,PG
01300		SETZ↔ARC. 0,PG
01400		LAC  E1,E0
01500	L2:	CCW  E2,E1
01600		SETZ↔SON 1,E1↔SKIPE 1↔SON. 0,1
01700		CALL(KLNODD,E1)
01800		CAMN E2,E0↔GO L3
01900		LAC  E1,E2↔GO L2
02000	
02100	;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
02200	L3:	CCW PG,PG
02300		CAME PG,PG0↔GO L1
02400		POP1J
02500	
02600	BEND KILVIC; BGB 5 JANUARY 1973 ----------------------------------
     

00100	SUBR(KLBABY)LEVEL	KILL: BABY POLYGONS OF A LEVEL.
00200	BEGIN KLBABY;-----------------------------------------------------
00300		ACCUMULATORS{A,PG,E0,E1,E2,Q,R}
00400		LAC 1,ARG1↔SON PG,1↔DAC PG,PG0#
00500	;KLUDGE - SPARE SON POLYGON UNTIL WE CAN THINK OF A POLICY.
00600		GO L3
00700	;ELIMINATE INSIGNIFICANT CONTOURS - SMALL LOW CONTRAST.
00800	L1:	NCNT 0,PG↔LACM
00900		CAIL =10↔GO L3
01000	
01100	;RELEASE VIC NODES OF THE POLYGON.
01200		SON E0,PG
01300		LAC  E1,E0
01400	L2:	CCW  E2,E1
01500		CALL(KLNODD,E1)
01600		CAMN E2,E0↔GO .+3
01700		LAC  E1,E2↔GO L2
01800	
01900	;KILL A BABY POLYGON.
02000		CAR Q,(PG)↔CDR R,(PG)
02100		DIP Q,(R)↔ DAP R,(Q)	;RINGO PG.
02200		CALL(KLNODD,PG)
02300		SKIPA PG,R		;CCW FROM OUT OF THE GRAVE.
02400	
02500	;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
02600	L3:	CCW PG,PG↔CAME PG,PG0↔GO L1
02700		POP1J
02800	
02900	BEND;1/6/73------------------------------------------------------
     

00100	SUBR(KLPGON)PGN		KILL: POLYGON AND RETURN CCW(PGN).
00200	BEGIN KLPGON;-----------------------------------------------------
00300		ACCUMULATORS{PG,E0,E1,E2,Q,R}
00400		LAC PG,ARG1
00500	
00600	;RELEASE VIC NODES OF THE POLYGON.
00700	
00800		SON E0,PG
00900		LAC  E1,E0
01000	L1:	CCW  E2,E1
01100		CALL(KLNODD,E1)
01200		CAMN E2,E0↔GO .+3
01300		LAC  E1,E2↔GO L1
01400	
01500	;RING OUT & KILL POLYGON NODE,
01600	
01700		NGON Q,PG↔PGON R,PG↔JUMPE R,L2
01800		NGON. Q,R↔PGON. R,Q↔CAMN PG,R↔SETZ R,
01900		EXO 1,PG↔JUMPE 1,.+4↔ENDO 0,1↔CAMN 0,PG↔ENDO. R,1
02000		ENDO 1,PG↔SKIPE 1↔ZIP 3(1) ;MY ENDO BECOMES AN ORPHAN.
02100	
02200	L2:	CAR Q,(PG)↔CDR R,(PG)
02300		DIP Q,(R)↔ DAP R,(Q)	;RINGO PG.
02400		CALL(KLNODD,PG)
02500	
02600	;DOES DAD NEED A NEW FIRST SON.
02700	
02800		DAD 1,R
02900		CAMN PG,R↔SETZ R,
03000		SON 0,1↔CAMN 0,PG↔SON. R,1
03100	
03200	;RETURN PGON CCW FROM OUT OF THE GRAVE.
03300		LAC 1,R
03400		POP1J
03500	
03600	BEND KLPGON;BGB 1 JANUARY 1973 ----------------------------------
     

00100	SUBR(SMOOTH)LEVEL	SMOOTH: CONTOURS INTO ARCS.
00200	BEGIN SMOOTH;-----------------------------------------------------
00300	
00400		ACCUMULATORS{V1,V2,PG,E0,E1,E2}
00500		SKIPN ESMOO↔POP1J
00600		LAC 1,ARG1
00700		SON PG,1↔SKIPN PG↔POP1J
00800	
00900	;POLYGON INITIALIZATION.
01000	
01100	L1:	DAC PG,PGSAVE#
01200		SON V1,PG↔DAC V1,E0SAVE#   ;UPPER MOST LEFT VERTEX.
01300		ARC V2,PG		   ;LOWER MOST RIGHT VERTEX.
01400		TESTZ V2,ARCBIT↔POP1J	   ;END OF LEVEL'S POLYGON RING.
01500	
01600	;CREATE ARC NODES AT POLYGON'S EXTREME CORNERS.
01700	
01800		SETQ(ARC2,{MKNODD,[VBIT+ARCBIT+VREL]})
01900		LAC RC(V2)↔DAC RC(1)↔SON. 1,V2↔SON. V2,1
02000		SETQ(ARC1,{MKNODD,[VBIT+ARCBIT+VREL]})
02100		LAC RC(V1)↔DAC RC(1)↔SON. 1,V1↔SON. V1,1
02200	
02300		LAC 2,ARC2↔CCW. 1,2↔CW. 1,2↔CCW. 2,1↔CW. 2,1
02400		DAD. PG,1↔DAD. PG,2↔ARC. 1,PG
02500	
02600	;CALL FOR CREATION OF THE INTERMEDIATE ARC NODES.
02700		DZM AVCNT
02800		CALL(MKARCS,ARC1,ARC2)
02900		CALL(MKARCS,ARC2,ARC1)
03000	
03100	;KILL TWO-SIDED ARC-POLYGONS AND ADVANCE TO NEXT POLYGON.
03200		SKIPN AVCNT↔GO[
03300	L2:		CALL(KLNODD,ARC1)
03400			CALL(KLNODD,ARC2)
03500			SETQ(PG,{KLPGON,PGSAVE})
03600			JUMPN PG,L1↔POP1J]
03700		LAC PG,PGSAVE↔CCW PG,PG↔GO L1
03800	
03900		LIT
04000		DECLARE{ARC1,ARC2}
04100	BEND SMOOTH; BGB 6 DECEMBER 1972 ---------------------------------
04200	
04300		DECLARE{AVCNT}	;ARC-VERTEX COUNT.
     

00100	;MKARCS(V1,V2).		SMOOTH: MAKE ARCS FROM V1 CCW TO V2.
00200	SUBR(MKARCS)V1,V2-------------------------------------------------
00300	BEGIN MKARCS
00400		ACCUMULATORS{D,U1,U2,V1,V2,A,B,C,U,V}
00500		LAC V1,ARG2↔LAC V2,ARG1
00600	;CHECK FOR TRIVAIL CASE.
00700	L0:	SON U1,V1↔SON U2,V2
00800		CCW 0,U1↔CAMN 0,U2↔GO L3
00900	
01000	;COMPUTE NORMALIZED ARC EDGE COEFFICIENTS.
01100		ROW A,V1↔FLO A,		; A ← Y1.
01200		COL B,V2↔FLO B,		; B ← X2.
01300		COL C,V1↔FLO C,		; C ← X1.
01400		ROW D,V2↔FLO D,		; D ← Y2.
01500		LAC 1,B↔FMPR 1,A	; 1 ← X2*Y1.
01600		FSBR A,D↔FSBR B,C	; A ← Y1-Y2.   B ← X2-X1.
01700		FMPR C,D↔FSBR C,1	; C ← X1*Y2 - X2*Y1.
01800		LAC 0,A↔FMPR 0,0↔LAC 1,B↔FMPR 1,1↔FADR 1,0
01900		CALL SQRT,1↔FDVR A,1↔FDVR B,1↔FDVR C,1
02000		LAC 0,A↔FMPR 0,A↔HLLM 0,6(V1)
02100		LAC 0,B↔FMPR 0,B↔HLRM 0,6(V1)
02200	
02300	;SET 'EM UP FOR AN ARC PASS.
02400		SON U1,V1↔SON U2,V2
02500		DZM DMAX#↔DZM DMIN#
02600		DZM VMAX#↔DZM VMIN#↔DZM MAXCON#
02700	;GO FROM U1 CCW TO U2 AND FIND THE U FURTHEST OFF THE ARC-EDGE.
02800	L1:	CCW U1,U1↔CAMN U1,U2↔GO L2
02900		COL 0,U1↔FLO 0,↔ROW 1,U1↔FLO 1,
03000		FMPR 0,A↔FMPR 1,B↔LAC D,C↔FADR D,0↔FADR D,1
03100		CAMGE D,DMIN↔GO [DAC U1,VMIN↔DAC D,DMIN↔GO .+1]
03200		CAMLE D,DMAX↔GO [DAC U1,VMAX↔DAC D,DMAX↔GO .+1]
03300	;KEEP TRACK OF MAXIMUM EDGE CONTRAST ALONG ARC.
03400		CNTRST 0,V1↔MOVM↔CAMLE MAXCON↔DAC MAXCON↔GO L1
03500	
03600	;WHEN EXTREMA EXCEED ARCWID[MAXCON] THEN FORM ARC-POINTS.
03700	L2:	LAC U,VMIN↔LACM DMIN
03800		CAMGE DMAX↔LAC U,VMAX
03900		CAMGE DMAX↔LAC DMAX
04000		LAC 1,MAXCON↔CAMGE ARCWID(1)↔GO L3
04100	;OLDE ESPLIT.
04200		SETQ(V,{MKNODD,[VBIT+ARCBIT+VREL]})↔AOS AVCNT
04300		SON. U,V↔SON. V,U
04400		LAC RC(U)↔DAC RC(V)↔DAD 0,U↔DAD. 0,V
04500		CCW. V,V1↔CW. V1,V
04600		CCW. V2,V↔CW. V,V2
04700		LAC V2,V↔GO L0
04800	;ADVANCE CCW AN ARC-EDGE OR EXIT.
04900	L3:	CAMN V2,ARG1↔POP2J
05000		LAC V1,V2↔CCW V2,V2↔GO L0
05100	BEND MKARCS; BGB 28 DECEMBER 1972 --------------------------------
     

00100	SUBR(HISTOG)		MISC: MAKE HISTOGRAM OF TVBUF.
00200	BEGIN HISTOG;--------------------------------------------------
00300		SKIPE FLGHIS↔POP0J↔SETOM FLGHIS
00400		LAC[XWD HISTO,HISTO+1]
00500		DZM HISTO↔BLT HISTO+77
00600		LAC 7,[XWD L,0]↔BLT 7,6↔GO 2
00700	
00800	;ACCUMULATOR LOOP.
00900	L:	=62208		;0
01000		0		;1
01100		ILDB 1,6	;2
01200		AOS HISTO(1)	;3
01300		SOJG 0,2	;4
01400		POP0J		;5
01500		POINT 6,TVBUF,-1;6
01600	
01700	BEND HISTOG; BGB 4 DECEMBER 1972 ---------------------------------
01800	END